home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / mstuff.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  3.2 KB  |  95 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module mstuff)
  13.  
  14. (DECLARE-TOP(SPLITFILE MSORT) (FIXNUM N))
  15.  
  16. (DEFMFUN $SORT N
  17.   (IF (OR (= N 0) (> N 2)) (MERROR "SORT takes 1 or 2 arguments."))
  18.   (LET ((LLIST (ARG 1)) COMPARFUN BFUN)
  19.        (IF (NOT ($LISTP LLIST))
  20.        (MERROR "The first argument to SORT must be a list:~%~M" LLIST))
  21.        (SETQ LLIST (copy-top-level (CDR LLIST) )
  22.          COMPARFUN 
  23.          (MFUNCTION1 (SETQ BFUN (IF (= N 2) (GETOPR (ARG 2)) 'LESSTHAN))))
  24.        (IF (MEMQ BFUN '(LESSTHAN GREAT))
  25.        (SETQ LLIST (MAPCAR #'RATDISREP LLIST)))
  26.        (CONS '(MLIST SIMP) (SORT LLIST COMPARFUN))))
  27.  
  28. ;; old non closure version
  29. ;;(DEFUN MFUNCTION1 (FUN)
  30. ;;  `(LAMBDA (X Y) (MEVALP `((,',FUN) ((MQUOTE) ,X) ((MQUOTE) ,Y)))))
  31.  
  32. ;; cmulisp does not like the closure version.  Clisp insists on the
  33. ;; closure version.  Gcl likes either...  For the moment we will
  34. ;; leave a conditional here.
  35. (DEFUN MFUNCTION1 (FUN)
  36.   #+cmu
  37.    (LAMBDA (X Y) (MEVALP `((,FUN) ((MQUOTE) ,X) ((MQUOTE) ,Y))))
  38.   #-cmu 
  39.   (function (LAMBDA (X Y) (MEVALP `((,FUN) ((MQUOTE) ,X) ((MQUOTE) ,Y)))))
  40.   )
  41.  
  42. (DEFUN LESSTHAN (A B) (IF (GREAT B A) T))
  43.  
  44. (declare-top (SPLITFILE MAKEL))
  45.  
  46. (DEFMSPEC $MAKELIST (X) (SETQ X (CDR X))
  47.    (PROG (N FORM ARG A B LV D)
  48.       (SETQ N (LENGTH X))
  49.       (IF (OR (< N 3) (> N 4))
  50.       (MERROR "MAKELIST takes 3 or 4 arguments."))
  51.       (SETQ FORM (CAR X)
  52.         ARG (CADR X)
  53.         A (MEVAL (CADDR X))
  54.         LV (COND ((= N 3) 
  55.               (IF ($LISTP A)
  56.               (MAPCAR #'(LAMBDA (U) (LIST '(MQUOTE) U)) (CDR A))
  57.               (MERROR "
  58. If 3 arguments are given to MAKELIST,
  59. the 3rd argument should evaluate to a list:~%~M" A)))
  60.              (T
  61.               (SETQ B (MEVAL (CADDDR X)))
  62.               (IF (OR (NOT (FIXNUMP (SETQ D (SUB* B A)))) (< D -1))
  63.               (MERROR "
  64. If 4 arguments are given to MAKELIST, the difference of the 3rd
  65. and 4th arguments should evaluate to a non-negative integer:~%~M" D)
  66.               (INTERVAL A B)))))
  67.       (RETURN 
  68.      (DO ((LV LV (CDR LV)) (ANS))
  69.          ((NULL LV) (CONS '(MLIST SIMP) (NREVERSE ANS)))
  70.          (SETQ ANS (CONS (MEVAL `(($EV)
  71.                       ,@(LIST (LIST '(MQUOTE) FORM)
  72.                       (LIST '(MEQUAL SIMP) 
  73.                         ARG 
  74.                         (CAR LV)))))
  75.                  ANS))))))
  76.  
  77. (DEFUN INTERVAL (I J)
  78.    (DO ((NN I (ADD2 1 NN)) (M 0 (f1+ M)) (K (SUB* J I)) (ANS))
  79.        ((> M K) (NREVERSE ANS))
  80.        (SETQ ANS (CONS NN ANS))))
  81.  
  82. (DEFMFUN $SUBLIST (A F)
  83.   (IF ($LISTP A)
  84.       (DO ((A (CDR A) (CDR A)) (X))
  85.       ((NULL A) (CONS '(MLIST SIMP) (NREVERSE X)))
  86.       (IF (MEVALP (LIST (NCONS F) (CAR A)))
  87.           (SETQ X (CONS (CAR A) X))))
  88.       (MERROR "The first argument to SUBLIST must be a list:~%~M" A)))
  89.  
  90. ; Undeclarations for the file:
  91. #-NIL
  92. (DECLARE-TOP(NOTYPE N))
  93.  
  94.  
  95.